home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / copy.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  30KB  |  1,075 lines
  1. /* ******************************************************************** */
  2. /*  copy.c        copyright (c) university of bath 1992            */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: copy.c,v 1.21 1992/03/13 18:06:51 pab Exp $
  9.  *
  10.  * $Log: copy.c,v $
  11.  * Revision 1.21  1992/03/13  18:06:51  pab
  12.  * SysV fixes (mainly relinquishing pages and synchonisation)
  13.  *
  14.  * Revision 1.20  1992/02/27  15:46:57  pab
  15.  * bytecode + error changes
  16.  *
  17.  * Revision 1.19  1992/02/13  13:49:58  pab
  18.  * *** empty log message ***
  19.  *
  20.  * Revision 1.17  1992/02/11  13:38:04  pab
  21.  * removed printing gc_enabled
  22.  *
  23.  * Revision 1.16  1992/02/10  12:11:41  pab
  24.  * fixed circular lists
  25.  * gc_enabaled now global
  26.  *
  27.  * revision 1.12  1991/04/02  21:25:30  kjp
  28.  * compiler tidying.
  29. /* copying garbage collector. Replaces allocate + garbage.c */
  30.  
  31. #include "structs.h"
  32. #include "funcalls.h"
  33. #include "global.h"
  34. #include "state.h"
  35. #include "copy.h"
  36.  
  37. /* Plural Hacks */
  38. /* ====== ===== */
  39.  
  40. LispObject ListOfStrangeThings;
  41.  
  42. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  43. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  44.  
  45. #define N_SLOTS_IN_CONDITION N_SLOTS_IN_STRUCT(struct condition_structure)
  46.  
  47.  
  48. #define OTHER_SPACE(x) 1-(x)
  49.  
  50. #define is_newspace(x) \
  51.   ((gcof(x)&1) ==wspace)
  52.  
  53. #undef set_forwarded
  54. #undef is_forwarded
  55. #define forwardof(x) \
  56.   (lval_classof(x))
  57.  
  58. #define set_forwarded(x, new) \
  59.   ( *(&gcof(x))|=0x2 , forwardof(x)=new)
  60.  
  61. #define is_forwarded(x) \
  62.   ((gcof(x))&0x2)
  63.   
  64. #define HEADERSIZE sizeof(Object_t)
  65. /* should not need to allocate any fixed objects yet... */
  66.  
  67. #define ROUND_ADDR(x) ((((int)x)&3)==0 ? x : x+(4-((int)x&3)))
  68. #define is_fixed(x) 0
  69.  
  70. /* which space are we in */
  71. static int wspace;
  72. static char *free_ptr;
  73. static char *pg_end;
  74. int gc_paranoia=0;
  75. static int collect_count;
  76.  
  77. /* BSD + SYSV */
  78. static LispObject GC_thread;
  79.   
  80. /* SYSV only */
  81. SYSTEM_GLOBAL(SystemSemaphore,GC_sem);
  82. SYSTEM_GLOBAL(SystemSemaphore,Rig_sem);
  83. SYSTEM_GLOBAL(int,GC_state);
  84. static SYSTEM_GLOBAL(int,GC_register);      /* Who's arrived so far... */
  85. static SYSTEM_GLOBAL(int,GC_exit_register); /* Who's left... */
  86. static SYSTEM_GLOBAL(int,GC_turn);         /* who's go */
  87. static SYSTEM_GLOBAL(int,gc_enabled);         /* can we... */
  88. static SYSTEM_GLOBAL_ARRAY1(LispObject,GC_register_array,MAX_PROCESSORS);
  89. static LispObject GC_tame_continue;
  90. static SYSTEM_GLOBAL(PageList, old_pages);
  91. /* Valid only in non-gc time */
  92. static SYSTEM_GLOBAL(PageList, free_pages);
  93. static SYSTEM_GLOBAL(int,npages);
  94. static SYSTEM_GLOBAL(int,pagelim);
  95.  
  96. static PageList current_page;
  97. static PageList used_pages;
  98.  
  99. /* Called from inside copier */
  100. #define ALLOC_SPACE(new,type,ptr,size) \
  101.   {  \
  102.     new= (type) ptr;         \
  103.     ptr+=size;             \
  104.     if (ptr>pg_end) \
  105.       {                \
  106.     GRAB_PAGE(NULL,ptr,pg_end);    \
  107.     new= (type) ptr;         \
  108.     ptr+=size;        \
  109.        }            \
  110.       }
  111.  
  112. #ifdef MACHINE_ANY
  113. #define GRAB_PAGE(stacktop,ptr,top)         \
  114.    {                     \
  115.       ptr=free_pages->start;         \
  116.       top=free_pages->end;         \
  117.       current_page=free_pages;        \
  118.       free_pages=free_pages->next;         \
  119.       current_page->next=used_pages;         \
  120.       used_pages=current_page;              \
  121.       npages++;                    \
  122.       COPY_BUG(fprintf(stderr,"{Grab: %d}",    \
  123.                current_page->id));    \
  124.     }
  125. #else
  126. #define GRAB_PAGE(stacktop,ptr,top)         \
  127.    {                     \
  128.       system_open_semaphore(stacktop,&S_G_V(GC_sem)); \
  129.       ptr=S_G_V(free_pages)->start;         \
  130.       top=S_G_V(free_pages)->end;         \
  131.       current_page=S_G_V(free_pages);        \
  132.       S_G_V(free_pages)=S_G_V(free_pages)->next;         \
  133.       current_page->next=used_pages;         \
  134.       used_pages=current_page;              \
  135.       S_G_V(npages)++;                    \
  136.       COPY_BUG(fprintf(stderr,"{Grab(%d): %d}",    \
  137.                system_scheduler_number,        \
  138.                current_page->id));        \
  139.       COPY_BUG(memset(ptr,'x',top-ptr));        \
  140.       system_close_semaphore(&S_G_V(GC_sem)); \
  141.     }
  142. #endif
  143.  
  144. #define PRINT_LISTS()        \
  145.   COPY_BUG({            \
  146.     PageList xx;        \
  147.     fputs("Free: ",stderr);    \
  148.     xx=S_G_V(free_pages);        \
  149.     while (xx!=NULL)        \
  150.       { fprintf(stderr,"%d ",xx->id);        \
  151.     xx=xx->next;        \
  152.       }                \
  153.     fputs("\nUsed: ",stderr);    \
  154.     xx=used_pages;        \
  155.     while (xx!=NULL)        \
  156.       { fprintf(stderr,"%d ",xx->id);        \
  157.     xx=xx->next;        \
  158.       }        \
  159.     fputc('\n',stderr);        \
  160.   })
  161.  
  162.  
  163. void init_allocator(int size)
  164. {
  165.   PageList *newpage;
  166.   char *space=system_malloc(2*size);
  167.   char *end=space+2*size;
  168.   int pg_count=0;
  169.  
  170.   COPY_BUG(memset(space,'T',2*size));
  171. #ifndef MACHINE_ANY
  172.  
  173.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,GC_sem,NULL);
  174.   system_allocate_semaphore(&S_G_V(GC_sem));
  175.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,Rig_sem,NULL);
  176.   system_allocate_semaphore(&S_G_V(Rig_sem));
  177.   SYSTEM_INITIALISE_GLOBAL(int,GC_state,GC_DONE);
  178.   SYSTEM_INITIALISE_GLOBAL(int,GC_register,0);
  179.   SYSTEM_INITIALISE_GLOBAL(int,GC_exit_register,0);
  180.   SYSTEM_INITIALISE_GLOBAL(int,pagelim,0);
  181.   SYSTEM_INITIALISE_GLOBAL(PageList,free_pages,NULL);
  182.   SYSTEM_INITIALISE_GLOBAL(PageList,old_pages,NULL);
  183.   SYSTEM_INITIALISE_GLOBAL(int,npages,NULL);
  184.   SYSTEM_INITIALISE_GLOBAL(int,GC_turn,NULL);
  185.   SYSTEM_INITIALISE_GLOBAL_ARRAY1(LispObject,
  186.                   GC_register_array,MAX_PROCESSORS,NULL);
  187. #endif
  188.  
  189.   SYSTEM_INITIALISE_GLOBAL(int,gc_enabled,NULL);
  190.   newpage= &S_G_V(free_pages);  
  191.   while (space<end)
  192.     {    
  193.       *newpage=(PageList) space;
  194.       (*newpage)->status=PAGE_FREE;
  195.       (*newpage)->end= ((space+PAGE_SIZE) < end ? space+PAGE_SIZE : end);
  196.       COPY_BUG((*newpage)->id=pg_count);
  197.       newpage= &((*newpage)->next);
  198.       space+=PAGE_SIZE;
  199.       pg_count++;
  200.     }
  201.   *newpage=NULL;
  202.   
  203.   printf("Initialised with: %x [%d pages]\n",size,pg_count);
  204.   PRINT_LISTS();
  205.   used_pages=NULL;
  206.   wspace=0;
  207.   S_G_V(pagelim)=pg_count/2;
  208.   S_G_V(npages)=0;
  209.   GRAB_PAGE(NULL,free_ptr,pg_end);
  210. }
  211.  
  212.  
  213. void runtime_initialise_garbage_collector(LispObject *stacktop)
  214. {
  215.   (GC_tame_continue)=allocate_continue(stacktop);
  216.   GC_thread=nil;
  217.  
  218.   add_root(&GC_tame_continue);
  219.   add_root(&GC_thread);
  220. }
  221.  
  222. void initialise_garbage(LispObject *stacktop)
  223. {  /* Pretend we're a module */
  224.   LispObject garbage_collect(LispObject *);
  225.  
  226.   GC_thread = allocate_thread(stacktop,2048,1024,0);
  227.   (void) make_module_function(stacktop,"GC",garbage_collect,0);
  228. }
  229.  
  230. /* Called when a new process forks */
  231. #ifndef MACHINE_ANY
  232. void runtime_reset_allocator(LispObject *stacktop)
  233. {
  234.   COPY_BUG(fprintf(stderr,"Proc: %d starting\n",system_scheduler_number));
  235.  
  236.   used_pages=NULL;
  237.   GRAB_PAGE(NULL,free_ptr,pg_end);
  238.  
  239.   GC_thread = allocate_thread(stacktop,2048,1024,0);
  240.   add_root(&GC_thread);
  241.   (GC_tame_continue)=allocate_continue(stacktop);
  242.   add_root(&GC_tame_continue);
  243.   system_open_semaphore(stacktop,&S_G_V(Rig_sem));
  244.   RIG_GC_THREAD(stacktop);
  245.   system_close_semaphore(&S_G_V(Rig_sem));
  246.  
  247. }
  248. #endif
  249.  
  250. #ifndef MACHINE_ANY
  251. EUFUN_0(garbage_collect)
  252. {
  253.   void do_gc_sync(LispObject *);
  254.  
  255.   do_gc_sync(stacktop);
  256.   return nil;
  257.  
  258. }
  259. EUFUN_CLOSE
  260. #else
  261. EUFUN_0(garbage_collect)
  262. {
  263.   void swap_spaces(LispObject *);
  264.  
  265.   swap_spaces(stacktop);
  266.   return nil;
  267. }
  268. EUFUN_CLOSE
  269. #endif
  270.  
  271.  
  272.  
  273. int current_space()
  274. {
  275.   return wspace;
  276. }
  277.  
  278. #ifndef MACHINE_ANY
  279. extern void rig_gc_thread(LispObject *stacktop)
  280. {
  281. #ifndef MACHINE_ANY
  282.   RIG_GC_THREAD(stacktop);
  283. #endif
  284. }
  285. #endif
  286.  
  287. /* c-roots */
  288. #define MAXROOTS 300
  289. static int nroots=0;
  290.  
  291. LispObject *roots[MAXROOTS];
  292.  
  293. int add_root(LispObject *root)
  294. {    
  295.   int x=nroots;
  296.  
  297.   roots[nroots++]=root;
  298.   
  299.   return x;
  300. }
  301.  
  302. void copy_root(LispObject *x)
  303. {
  304.   LispObject copy_object(LispObject);
  305.   *x=copy_object(*x);
  306. }
  307.  
  308. void copy_on()
  309. {
  310.   S_G_V(gc_enabled)++;
  311.   COPY_BUG(fprintf(stderr,"{+%d}",S_G_V(gc_enabled)));
  312. }
  313.  
  314. void copy_off()
  315. {
  316.   S_G_V(gc_enabled)--;
  317.   COPY_BUG(fprintf(stderr,"{-%d}",S_G_V(gc_enabled)));
  318. }
  319.  
  320. /* These will have to more complicated eventually */
  321. void ON_collect()
  322. {
  323.   S_G_V(gc_enabled)++;
  324.   COPY_BUG(fprintf(stderr,"{+%d}",S_G_V(gc_enabled)));
  325. }
  326.  
  327. void OFF_collect()
  328. {
  329.   S_G_V(gc_enabled)--;
  330.   COPY_BUG(fprintf(stderr,"{-%d}",S_G_V(gc_enabled)));
  331. }
  332. /****************************************
  333.  * allocation 
  334.  ****************************************/
  335.  
  336. static int a_count;
  337. #define ALLOC_GAP 2048
  338. int alloc_gap=ALLOC_GAP;
  339.  
  340. LispObject allocate_nbytes(LispObject *stacktop,int n,int type)
  341. {
  342. #ifdef MACHINE_ANY  
  343.   void swap_spaces(LispObject *);
  344. #else
  345.   void do_gc_sync(LispObject *);
  346. #endif
  347.   LispObject object;
  348.   char *new;
  349.   
  350.   COPY_BUG(if (n<HEADERSIZE) fprintf(stderr,"Object too small to hold header\n") );
  351.  
  352. #ifndef NODEBUG  
  353.   if (gc_paranoia)
  354.     fprintf(stdout,"{%x:%d}",type,n);
  355. #endif
  356.   n=ROUND_ADDR(n);
  357.   a_count+=n;
  358. #ifdef NODEBUG
  359.   if ( !(free_ptr+n<pg_end))
  360. #else
  361.   if ((gc_paranoia && a_count>alloc_gap && S_G_V(gc_enabled))
  362.       || !(free_ptr+n<pg_end))
  363. #endif    
  364.     {
  365.       if (S_G_V(npages)<=S_G_V(pagelim))
  366.     {
  367.       GRAB_PAGE(stacktop,free_ptr,pg_end);
  368.     }
  369.       else
  370.     {
  371.       a_count=0;
  372.       if (S_G_V(gc_enabled)<1)
  373.         { 
  374.           fprintf(stderr,"{Grabbed Page 'cos I couldn't GC[%d]}\n",S_G_V(gc_enabled));
  375.           GRAB_PAGE(stacktop,free_ptr,pg_end);
  376.         }
  377.       else
  378.         {
  379. #ifdef MACHINE_ANY      
  380.           swap_spaces(stacktop);
  381. #else 
  382.           do_gc_sync(stacktop);
  383. #endif
  384.         }
  385.     }
  386.     }
  387.   new=free_ptr;
  388.   free_ptr+=n;    
  389.   object=(LispObject) new;
  390.  
  391.   lval_typeof(object)=type;
  392.   gcof(object)=(short)wspace;
  393.   return(object);
  394. }
  395.  
  396. #ifndef MACHINE_ANY
  397.  
  398. void do_gc_sync(LispObject *stacktop)
  399. {
  400.   void swap_spaces(LispObject *);
  401.   int i;
  402.  
  403.   /* we must save state early */
  404.   save_state(stacktop,CURRENT_THREAD()->THREAD.state);
  405.   /* Wait for the last gc to finish */
  406.   while (  S_G_V(GC_state)!=GC_DONE
  407.      &&S_G_V(GC_state)!=GC_SINKING)
  408.     ;
  409.   /* register myself */
  410.   system_open_semaphore(stacktop,&S_G_V(GC_sem));
  411.   ++S_G_V(GC_register);
  412.   if (S_G_V(GC_register) == 1)
  413.     {                    /* First */
  414.       S_G_V(GC_state) = GC_SINKING;
  415.       S_G_V(old_pages) = NULL;
  416.       fprintf(stderr,"GC sinking(%d) ---  ",S_G_V(gc_enabled));
  417.     }
  418.   fprintf(stderr,"%d ",system_scheduler_number);
  419.   /* if last, set flag */
  420.   if (S_G_V(GC_register) == RUNNING_PROCESSORS())
  421.     { /* Last */
  422.       S_G_V(GC_state) = GC_REGISTERED;
  423.       fprintf(stderr,"\n ",system_scheduler_number); fflush(stdout);
  424.       S_G_V(GC_turn)=0;
  425.     }        
  426.   
  427.   system_close_semaphore(&S_G_V(GC_sem));
  428.   
  429.  
  430.   SYSTEM_GLOBAL_ARRAY1_VALUE(GC_register_array,system_scheduler_number) 
  431.     = CURRENT_THREAD();
  432.   
  433.   /* boot any sleepers */
  434.  
  435.   system_kick_sleepers();
  436.  
  437.   /* wait until all get the idea */
  438.   while (S_G_V(GC_state)!=GC_REGISTERED)
  439.     ;
  440.   /* Save myself */
  441.  
  442.   /* we all copy --- in serial 'cos its easier that way */
  443.  
  444.   while(S_G_V(GC_turn)!=system_scheduler_number)
  445.     ;
  446.  
  447.   if (!set_continue(stacktop,(GC_tame_continue)))
  448.     {
  449.       LispObject temp = CURRENT_THREAD();
  450.       LispObject *newstack;
  451.  
  452.       COPY_BUG(fprintf(stderr," {Proc: %d leaping %x %x %x}\n",system_scheduler_number,
  453.                (GC_tame_continue)->CONTINUE.thread,GC_thread,temp));
  454.       newstack = load_thread(GC_thread);
  455.       call_continue(newstack,GC_thread->THREAD.state,temp);
  456.     }
  457.   
  458.   /* done: should signal this */
  459.  
  460.   S_G_V(GC_turn)++;
  461.   
  462.   if (system_scheduler_number==RUNNING_PROCESSORS()-1)
  463.     {    
  464.       static void free_old_pgs(void);
  465.  
  466.       S_G_V(GC_state)=GC_MARKED;
  467.       free_old_pgs();
  468.     }
  469.  
  470.   while(S_G_V(GC_state)!=GC_MARKED)
  471.       ;
  472.   /* Now we can go */
  473.  
  474.   system_open_semaphore(stacktop,&S_G_V(GC_sem));
  475.   --S_G_V(GC_register);
  476.   if (S_G_V(GC_register)==0)
  477.     S_G_V(GC_state)=GC_DONE;
  478.   system_close_semaphore(&S_G_V(GC_sem));
  479.  
  480.   
  481.   fprintf(stderr,"GC done\n");
  482.   
  483. }
  484.  
  485.  
  486. void first_gc_mark_call(LispObject *stacktop)
  487. {
  488.   void swap_spaces(LispObject *stacktop);
  489.  
  490.   LispObject ret;
  491.  
  492.   COPY_BUG(printf("First invokation of GC mark: %x\n",stacktop); fflush(stdout));
  493.   stacktop=GC_thread->THREAD.gc_stack_base;
  494.  reset:
  495.  
  496.   ret = GC_thread->THREAD.state->CONTINUE.value;
  497.  
  498.   COPY_BUG(printf("Laying continue in GC mark: %x\n",stacktop); fflush(stdout));    
  499.   if (set_continue(stacktop,(GC_thread->THREAD.state)))
  500.     {    
  501.       goto reset;
  502.     }
  503.   STACK_TMP(ret);
  504.  
  505.   COPY_BUG(printf("Marking in GC mark\n"); fflush(stdout));
  506.  
  507.   swap_spaces(stacktop);
  508.   UNSTACK_TMP(ret);
  509.   COPY_BUG(fprintf(stderr,"Jumping back: target: (%x %d) %x %d %d %d %d\n  gc_thread: (%x %d) %x %d %d\n",
  510.            ret,ret->THREAD.header.gc,
  511.            ret->THREAD.state, 
  512.            ret->THREAD.state->CONTINUE.header.gc,
  513.            ret->THREAD.state->CONTINUE.header.type,
  514.            ret->THREAD.state->CONTINUE.handler_stack->CONS.header.type,
  515.            ret->THREAD.state->CONTINUE.handler_stack->CONS.header.gc,
  516.            GC_thread,
  517.            GC_thread->THREAD.header.gc,
  518.            GC_thread->THREAD.state, 
  519.            GC_thread->THREAD.state->CONTINUE.header.gc,
  520.            GC_thread->THREAD.state->CONTINUE.header.type);
  521.        fflush(stdout));
  522.   /**save_state(stacktop,GC_thread);**/
  523.   (void) load_thread(ret); /* this returns the wrong value for our porpoises */
  524.   call_continue(NULL,(GC_tame_continue),nil);
  525. }
  526. #endif
  527.  
  528.  
  529.  
  530. /* Collection */
  531.  
  532. void swap_spaces(LispObject *stacktop)
  533. {
  534. /* Plural Hacks */
  535. /* ====== ===== */
  536.  
  537.   extern void keep_strange_things();
  538.   void copy_root(LispObject *);
  539.   void show_stack_space(void);
  540.   void free_old_pgs(void);
  541.   char *oldspace;
  542.   PageList pg,tmp,*ptr;
  543.   int i;
  544.  
  545. #ifdef MACHINE_ANY
  546.   S_G_V(old_pages)=NULL;
  547. #endif
  548.   fprintf(stderr,"Collection %d initiated: %d used, %d bytes (%d%%) remaining\n",
  549.       collect_count,S_G_V(npages)*PAGE_SIZE,(S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,0);
  550.  
  551.   /* make sure that all is well */
  552.   save_state(stacktop,CURRENT_THREAD()->THREAD.state);
  553.   PRINT_LISTS();
  554.   
  555.   pg=current_page;
  556.   used_pages=NULL;
  557.   S_G_V(npages)=0;
  558.   wspace=1-wspace;
  559.   /* begin the copy process */
  560.   GRAB_PAGE(stacktop,free_ptr,pg_end);
  561.  
  562.   for (i=0; i < nroots; i++)
  563.     copy_root(roots[i]);
  564.  
  565.   /* Free all oldspace */
  566.   /* Assumes that free_pages is unlocked */
  567.   while (pg!=NULL)
  568.     { /* Be better to nconc the pages */
  569.       tmp=pg->next;
  570. #ifdef CONS_PG      
  571.       pg->next=S_G_V(free_pages);
  572.       S_G_V(free_pages)=pg;
  573. #else
  574.       ptr=&S_G_V(old_pages);
  575.       if (*ptr!=NULL)
  576.     {
  577.       while ((*ptr)->next!=NULL
  578.          && (*ptr)->next->id < pg->id)
  579.         ptr=&(*ptr)->next;
  580.       
  581.       pg->next=(*ptr)->next;
  582.       (*ptr)->next=pg;
  583.     }
  584.       else 
  585.     {
  586.       *ptr=pg;
  587.       pg->next=NULL;
  588.     }
  589.     
  590. #endif
  591.       pg=tmp;
  592.     }
  593.   
  594.   fprintf(stderr,"Collection Completed: %d used, %d bytes (%d%%) remaining\n",
  595.       S_G_V(npages)*PAGE_SIZE,
  596.       (S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,
  597.       ((S_G_V(pagelim)-S_G_V(npages))*100)/
  598.       S_G_V(pagelim));
  599.   show_stack_space();
  600.   collect_count++;
  601.   PRINT_LISTS();
  602.  
  603. /* Plural Hacks */
  604. /* ====== ===== */
  605.  
  606.   keep_strange_things( ListOfStrangeThings );
  607.   ListOfStrangeThings = 0;
  608.  
  609.   return;
  610. }
  611.  
  612. void free_old_pgs()
  613. {
  614.   PageList tmp;
  615.  
  616.   tmp=S_G_V(free_pages);
  617.   while(tmp->next!=NULL)
  618.     {
  619.       tmp=tmp->next;
  620.     }
  621.   tmp->next=S_G_V(old_pages);
  622.   
  623. }
  624.  
  625. #ifndef NODEBUG
  626. #define CAREFUL_DECLS   \
  627.    LispObject copied; 
  628.  
  629. #ifdef NOLOWTAGINTS
  630. #define copy_obj_careful(x) \
  631.   (copied=copy_object(x),  \
  632.    copied==NULL || ((gcof(copied)&1)==wspace)  \
  633.    ? copied             \
  634.    : (fprintf(stderr,"Wrong space\n"), system_lisp_exit(0), nil))
  635. #else 
  636. #define  copy_obj_careful(x) \
  637.    (copied=copy_object(x),    \
  638.     (copied==NULL || is_fixnum(x) || ((gcof(copied)&1)==wspace))  \
  639.     ? copied \
  640.     : (fprintf(stderr,"Wrong space\n"), system_lisp_exit(0), nil))
  641.  
  642. #endif NOLOWTAGINTS
  643. #else
  644. #define CAREFUL_DECLS 
  645. #define copy_obj_careful(x) (copy_object(x))
  646. #endif
  647.  
  648. #define FORWARD_HEADER(new,obj) \
  649.   lval_typeof(new)=lval_typeof(obj);    \
  650.   gcof(new)=wspace;            \
  651.   class=lval_classof(obj);        \
  652.   set_forwarded(obj,new);
  653.  
  654. #define COPY_ALLOC_SPACE(ptr,size)        \
  655.   ALLOC_SPACE(new,LispObject,ptr,size);
  656.  
  657. /* Hack the stackpointer for GRAB_PAGE */
  658.  
  659. LispObject copy_object(LispObject obj)
  660. {
  661. /* Plural Hacks */
  662. /* ====== ===== */
  663.  
  664.   LispObject strange;
  665.  
  666.   int i;
  667.   LispObject new;
  668.   LispObject class;
  669.   CAREFUL_DECLS;
  670.  
  671.   if (obj==NULL) return NULL;
  672. #ifndef NOLOWTAGINTS
  673.   if (is_fixnum(obj)) return obj;
  674. #endif
  675.  
  676.   if (is_forwarded(obj))
  677.     return forwardof(obj);
  678.  
  679.   if (is_newspace(obj))
  680.     return obj;
  681.   else
  682.     {
  683.       switch(lval_typeof(obj))
  684.     {
  685.     case TYPE_NULL:
  686. #if 0
  687.     case TYPE_CONS:
  688. #endif
  689.       /* Null is (cons nil  nil) with hacked type */
  690.       COPY_ALLOC_SPACE(free_ptr,  sizeof(struct cons_structure));
  691.       FORWARD_HEADER(new,obj);
  692.       lval_classof(new)=copy_obj_careful(class);
  693.       CAR(new)=copy_obj_careful(CAR(obj));
  694.       CDR(new)=copy_obj_careful(CDR(obj));
  695.       break;
  696. #if 1
  697.     case TYPE_CONS:
  698.       /* allocate space */
  699.       {    
  700.         LispObject walker,newcons;
  701.         int count, max;
  702.         COPY_ALLOC_SPACE(free_ptr,  sizeof(struct cons_structure));
  703.         FORWARD_HEADER(new,obj);
  704.  
  705.         CAR(new)=class;
  706.         walker=CDR(obj);
  707.         max=1;
  708.         /* Note: this loop does not copy anything */
  709.         while (   walker!=NULL
  710. #ifdef NOLOWTAGINTS
  711.            && !is_fixnum(walker)
  712. #endif
  713.            && is_cons(walker)
  714.            && !is_forwarded(walker)
  715.            && !is_newspace(walker))
  716.           {
  717.         ALLOC_SPACE(newcons,LispObject,free_ptr,  sizeof(struct cons_structure));
  718.         FORWARD_HEADER(newcons,walker);
  719.         /* Keep the class safe */
  720.         CAR(newcons)=class;
  721.         walker=CDR(walker);
  722.         max++;
  723.           }
  724.         /* COPY_BUG(fprintf(stderr,"(List: %d elts",max)); */
  725.  
  726.         newcons=new;
  727.         /* This loop does all the copying 
  728.            end is now the stopping point */
  729.         
  730.         count=0;
  731.         walker=obj;
  732.         while (count<max)
  733.           {
  734.         lval_classof(newcons)=copy_obj_careful(CAR(newcons));
  735.         CAR(newcons)=copy_obj_careful(CAR(walker));
  736.         /* except for the end case equiv to CDR(newcons)=newcons+a bit */
  737.         CDR(newcons)=copy_obj_careful(CDR(walker));
  738.         walker=CDR(walker);
  739.         newcons=CDR(newcons);
  740.         count++;
  741.           }    
  742.       }
  743.       break;
  744. #endif
  745. #ifdef NOLOWTAGINTS      
  746.     case TYPE_INT:
  747.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct integer_structure));
  748.       FORWARD_HEADER(new,obj);
  749.       lval_classof(new)=copy_obj_careful(class);
  750.       intval(new)=intval(obj);
  751.       break;
  752. #endif
  753.     case TYPE_ENV:
  754.        COPY_ALLOC_SPACE(free_ptr,sizeof(struct envobject));
  755.       FORWARD_HEADER(new,obj);
  756.       lval_classof(new)=copy_obj_careful(class);
  757.       new->ENV.variable = copy_obj_careful(obj->ENV.variable);
  758.       new->ENV.value = copy_obj_careful(obj->ENV.value);
  759.       new->ENV.next = (Env) copy_obj_careful((LispObject)obj->ENV.next);
  760.       new->ENV.mutable = copy_obj_careful(obj->ENV.mutable);
  761.       break;
  762.  
  763.     case TYPE_METHOD:
  764.     case TYPE_GENERIC:
  765.     case TYPE_B_FUNCTION:
  766.     case TYPE_B_MACRO:
  767.     case TYPE_INSTANCE:
  768.       /* allocate space */
  769.       i=lval_classof(obj)->CLASS.local_count;
  770.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  771.       FORWARD_HEADER(new,obj);
  772.       
  773.       lval_classof(new)=copy_obj_careful(class);
  774.       for (i=0 ; i<class->CLASS.local_count ; i++)
  775.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  776.       break;
  777.       
  778.     case TYPE_VECTOR:
  779.       COPY_ALLOC_SPACE(free_ptr,sizeof(Object_t)+sizeof(int)+sizeof(LispObject)*obj->VECTOR.length);
  780.       FORWARD_HEADER(new,obj);
  781.       lval_classof(new)= copy_obj_careful(class);
  782.       new->VECTOR.length=obj->VECTOR.length;
  783.       for (i=0; i<obj->VECTOR.length; i++)
  784.         vref(new,i) = copy_obj_careful(vref(obj,i));
  785.       break;
  786.  
  787.     case TYPE_STRING:
  788.       COPY_ALLOC_SPACE(free_ptr,ROUND_ADDR(sizeof(Object_t)+obj->STRING.length+sizeof(int)));
  789.       FORWARD_HEADER(new,obj);
  790.       lval_classof(new)=copy_obj_careful(class);
  791.       new->STRING.length=obj->STRING.length;
  792.       strncpy(stringof(new),stringof(obj),obj->STRING.length+1);
  793.       break;
  794.  
  795.     case TYPE_CLASS:
  796.       i=lval_classof(obj)->CLASS.local_count;
  797.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  798.       FORWARD_HEADER(new,obj);
  799.       lval_classof(new)=copy_obj_careful(class);
  800.       (new->CLASS).name = copy_obj_careful(obj->CLASS.name);
  801.       (new->CLASS).superclasses = copy_obj_careful(obj->CLASS.superclasses);
  802.       (new->CLASS).subclasses = copy_obj_careful(obj->CLASS.subclasses);
  803.       (new->CLASS).slot_table = copy_obj_careful(obj->CLASS.slot_table);
  804.       (new->CLASS).slot_list = copy_obj_careful(obj->CLASS.slot_list);
  805.       (new->CLASS).direct_slot_list = copy_obj_careful(obj->CLASS.direct_slot_list);
  806.       (new->CLASS).precedence = copy_obj_careful(obj->CLASS.precedence);
  807.       (new->CLASS).local_count = obj->CLASS.local_count;
  808.       for (i=N_SLOTS_IN_CLASS ; i<class->CLASS.local_count ; i++)
  809.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  810.       break;
  811.  
  812.     case TYPE_CHAR:
  813.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct character_structure));
  814.       FORWARD_HEADER(new,obj);
  815.       lval_classof(new)=copy_obj_careful(class);
  816.       new->CHAR.font=obj->CHAR.font;
  817.       new->CHAR.code=obj->CHAR.code;
  818.       break; 
  819.  
  820.     case TYPE_TABLE:
  821.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct table_structure));
  822.       FORWARD_HEADER(new,obj);
  823.       lval_classof(new)=copy_obj_careful(class);
  824.       new->TABLE.comparator=obj->TABLE.comparator;
  825.       new->TABLE.lisp_comparator= copy_obj_careful(obj->TABLE.lisp_comparator);
  826.       new->TABLE.tree= copy_obj_careful(obj->TABLE.tree);
  827.       break;
  828.  
  829.     case TYPE_CONTINUE:
  830.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct continue_structure));
  831.       FORWARD_HEADER(new,obj);
  832.       lval_classof(new)=copy_obj_careful(class);
  833.       (new->CONTINUE).thread = copy_obj_careful(obj->CONTINUE.thread);
  834.       
  835.       (new->CONTINUE).value = copy_obj_careful(obj->CONTINUE.value);
  836.       (new->CONTINUE).target = copy_obj_careful((obj->CONTINUE).target);
  837.  
  838.       bcopy((char*)(obj->CONTINUE).machine_state, 
  839.         (char *)new->CONTINUE.machine_state,
  840.         sizeof(new->CONTINUE.machine_state));
  841.       (new->CONTINUE).gc_stack_pointer = obj->CONTINUE.gc_stack_pointer;
  842.  
  843.       (new->CONTINUE).dynamic_env = (Env)copy_obj_careful((LispObject)obj->CONTINUE.dynamic_env);
  844.       (new->CONTINUE).last_continue = copy_obj_careful(obj->CONTINUE.last_continue);
  845.       (new->CONTINUE).handler_stack = copy_obj_careful(obj->CONTINUE.handler_stack);
  846.       (new->CONTINUE).dp = copy_obj_careful(obj->CONTINUE.dp);
  847.  
  848.       (new->CONTINUE).live = obj->CONTINUE.live;
  849.       (new->CONTINUE).unwind = obj->CONTINUE.unwind;  
  850.       break;
  851.       
  852.     case TYPE_SPECIAL:
  853.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct special_structure));
  854.       FORWARD_HEADER(new,obj);
  855.       lval_classof(new)=copy_obj_careful(class);
  856.       new->SPECIAL.name = copy_obj_careful(obj->SPECIAL.name);
  857.       new->SPECIAL.env = (Env)copy_obj_careful((LispObject)obj->SPECIAL.env);
  858.       new->SPECIAL.func = obj->SPECIAL.func;
  859.       break;
  860.  
  861.     case TYPE_SYMBOL:    
  862.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct symbol_structure));
  863.       FORWARD_HEADER(new,obj);
  864.       lval_classof(new)=copy_obj_careful(class);
  865.       (new->SYMBOL).pname = obj->SYMBOL.pname;
  866.       (new->SYMBOL).lvalue = copy_obj_careful(obj->SYMBOL.lvalue);
  867.       (new->SYMBOL).lmodule = copy_obj_careful(obj->SYMBOL.lmodule);
  868.       (new->SYMBOL).gvalue = copy_obj_careful(obj->SYMBOL.gvalue);
  869.       (new->SYMBOL).plist = copy_obj_careful(obj->SYMBOL.plist);
  870.       (new->SYMBOL).left = copy_obj_careful(obj->SYMBOL.left);
  871.       (new->SYMBOL).right = copy_obj_careful(obj->SYMBOL.right);
  872.       (new->SYMBOL).hash = (obj->SYMBOL.hash);
  873.       break;
  874.  
  875.     case TYPE_STREAM:
  876.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct stream_structure));
  877.       FORWARD_HEADER(new,obj);
  878.       lval_classof(new) = copy_obj_careful(class);
  879.       (new->STREAM).handle = obj->STREAM.handle;
  880.       (new->STREAM).name = copy_obj_careful(obj->STREAM.name);
  881.       (new->STREAM).mode = obj->STREAM.mode;
  882.       (new->STREAM).curchar = new->STREAM.curchar;
  883.       break;
  884.       
  885.     case TYPE_C_MODULE: /* These are statically allocated, so just mark */
  886.       /* forward to here -- unset fwd bit+ set right space */
  887.       gcof(obj)=wspace; new=obj;
  888.       class=lval_classof(obj);
  889.       lval_classof(obj)=copy_obj_careful(class);
  890.       obj->C_MODULE.name=copy_obj_careful(obj->C_MODULE.name);
  891.       obj->C_MODULE.home=copy_obj_careful(obj->C_MODULE.home);
  892.       obj->C_MODULE.imported_modules=copy_obj_careful(obj->C_MODULE.imported_modules);
  893.       obj->C_MODULE.exported_names=copy_obj_careful(obj->C_MODULE.exported_names);
  894.       obj->C_MODULE.bindings=copy_obj_careful(obj->C_MODULE.bindings);
  895.       
  896.       for (i=0; i< obj->C_MODULE.entry_count; i++)
  897.         obj->C_MODULE.values[i]=copy_obj_careful(obj->C_MODULE.values[i]);
  898.  
  899.       break;
  900.  
  901.     case TYPE_I_MODULE:
  902.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct i_module_structure));
  903.       FORWARD_HEADER(new,obj);
  904.       lval_classof(new)= copy_obj_careful(class);
  905.       new->I_MODULE.name= copy_obj_careful(obj->I_MODULE.name);
  906.       new->I_MODULE.home= copy_obj_careful(obj->I_MODULE.home);
  907.       new->I_MODULE.imported_modules= copy_obj_careful(obj->I_MODULE.imported_modules);
  908.       new->I_MODULE.exported_names= copy_obj_careful(obj->I_MODULE.exported_names);
  909.       new->I_MODULE.bindings= copy_obj_careful(obj->I_MODULE.bindings);
  910.       new->I_MODULE.bounce_flag= obj->I_MODULE.bounce_flag;
  911.       break;
  912.  
  913.     case TYPE_C_FUNCTION:
  914.     case TYPE_C_MACRO:
  915.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct c_function_structure));
  916.       FORWARD_HEADER(new,obj);
  917.       lval_classof(new) = copy_obj_careful(class);
  918.       new->C_FUNCTION.name = copy_obj_careful(obj->C_FUNCTION.name);
  919.       new->C_FUNCTION.home = copy_obj_careful(obj->C_FUNCTION.home);
  920.       new->C_FUNCTION.env = (Env)copy_obj_careful((LispObject)obj->C_FUNCTION.env);
  921.       new->C_FUNCTION.argtype = obj->C_FUNCTION.argtype;
  922.       new->C_FUNCTION.func=obj->C_FUNCTION.func;
  923.       break;
  924.       
  925.     case TYPE_I_FUNCTION:    
  926.     case TYPE_I_MACRO:
  927.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct i_function_structure));
  928.       FORWARD_HEADER(new,obj);
  929.       lval_classof(new)=copy_obj_careful(class);
  930.       new->I_FUNCTION.name=copy_obj_careful(obj->I_FUNCTION.name);
  931.       new->I_FUNCTION.home=copy_obj_careful(obj->I_FUNCTION.home);
  932.       new->I_FUNCTION.env=(Env)copy_obj_careful((LispObject)obj->I_FUNCTION.env);
  933.       new->I_FUNCTION.bvl=copy_obj_careful(obj->I_FUNCTION.bvl);
  934.       new->I_FUNCTION.body=copy_obj_careful(obj->I_FUNCTION.body);
  935.       new->I_FUNCTION.argtype=obj->I_FUNCTION.argtype;
  936.       break;
  937.  
  938.     case TYPE_FLOAT:
  939.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct float_structure));
  940.       FORWARD_HEADER(new,obj);
  941.       lval_classof(new)=copy_obj_careful(class);
  942.       new->FLOAT.fvalue=obj->FLOAT.fvalue;
  943.       break;
  944. #if 0      
  945.     case TYPE_LISTENER:
  946.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct listener_structure));
  947.       FORWARD_HEADER(new,obj);
  948.       lval_classof(new)=copy_obj_careful(class);
  949.       bcopy(&(obj->LISTENER.socket),&(new->LISTENER.socket),sizeof(new->LISTENER.socket));
  950.       bcopy(&(obj->LISTENER.name),&(new->LISTENER.name),sizeof(new->LISTENER.name));
  951.       bcopy(&(obj->LISTENER.state),&(new->LISTENER.state),sizeof(new->LISTENER.state));
  952.       break;
  953.  
  954.     case TYPE_SOCKET:
  955.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct socket_structure));
  956.       FORWARD_HEADER(new,obj);
  957.       lval_classof(new)=copy_obj_careful(class);
  958.       bcopy(&(obj->SOCKET.socket),&(new->SOCKET.socket),sizeof(new->SOCKET.socket));
  959.       bcopy(&(obj->SOCKET.name),&(new->SOCKET.name),sizeof(new->SOCKET.name));
  960.       bcopy(&(obj->SOCKET.state),&(new->SOCKET.state),sizeof(new->SOCKET.state));
  961.       bcopy((obj->SOCKET.buffer),(new->SOCKET.buffer),sizeof(new->SOCKET.buffer));
  962.       break;
  963. #endif
  964.     case TYPE_THREAD:
  965.       i=lval_classof(obj)->CLASS.local_count;
  966.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  967.       FORWARD_HEADER(new,obj);
  968.       lval_classof(new) = copy_obj_careful(class);
  969.       new->THREAD.stack_size = obj->THREAD.stack_size;
  970.       new->THREAD.gc_stack_size = obj->THREAD.gc_stack_size; 
  971.  
  972.       new->THREAD.fun = copy_obj_careful(obj->THREAD.fun);
  973.       new->THREAD.args = copy_obj_careful(obj->THREAD.args);
  974.       new->THREAD.value = copy_obj_careful(obj->THREAD.value);
  975.  
  976.       new->THREAD.status = obj->THREAD.status;
  977.  
  978.       new->THREAD.parent = copy_obj_careful(obj->THREAD.parent);
  979.       new->THREAD.cochain = copy_obj_careful(obj->THREAD.cochain);
  980.   
  981.       new->THREAD.state = copy_obj_careful(obj->THREAD.state);
  982.     
  983.       new->THREAD.stack_base = obj->THREAD.stack_base;
  984.       new->THREAD.gc_stack_base = obj->THREAD.gc_stack_base;
  985.       for (i=N_SLOTS_IN_THREAD ; i<class->CLASS.local_count ; i++)
  986.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  987.       /* hack */
  988.       if (obj->THREAD.gc_stack_base+obj->THREAD.gc_stack_size < obj->THREAD.state->CONTINUE.gc_stack_pointer)
  989.         fprintf(stderr,"GC Stack overflow detected\n");
  990.  
  991.       {         
  992.         LispObject *x=obj->THREAD.gc_stack_base;
  993.         
  994.         while (x<obj->THREAD.state->CONTINUE.gc_stack_pointer)
  995.           { 
  996.         if (!(((int) *x)&1)) /* Check for tags here */
  997.           *x = copy_obj_careful(*x);
  998.         ++x;
  999.           }
  1000.       }
  1001.       break;
  1002.       
  1003.     case TYPE_SEMAPHORE:
  1004.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct semaphore_structure));
  1005.       FORWARD_HEADER(new,obj);
  1006.       lval_classof(new)=copy_obj_careful(class);
  1007.       new->SEMAPHORE.semaphore=obj->SEMAPHORE.semaphore;
  1008.       break;
  1009.       
  1010. /* Plural Hacks */
  1011. /* ====== ===== */
  1012.  
  1013.     case TYPE_STRANGE:
  1014.       i=lval_classof(obj)->CLASS.local_count;
  1015.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  1016.       FORWARD_HEADER(new,obj);
  1017.       ALLOC_SPACE(strange, LispObject, free_ptr,
  1018.               sizeof(struct cons_structure));                         
  1019.       CAR(strange) = new;                                                 
  1020.       CDR(strange) = (ListOfStrangeThings == 0) ? strange 
  1021.                                                 : ListOfStrangeThings;
  1022.       ListOfStrangeThings = strange;                                      
  1023.       lval_classof(new)=copy_obj_careful(class);                          
  1024.       for (i=0 ; i<class->CLASS.local_count ; i++)                        
  1025.         slotref(new,i) = copy_obj_careful(slotref(obj,i));                
  1026.       break;                                                              
  1027.       
  1028.     default:
  1029.       fprintf(stderr,"Can't copy: %x\n",typeof(obj));
  1030.       return obj;
  1031.       break;
  1032.     }
  1033.       return new;
  1034.     }
  1035. }
  1036.  
  1037. /*****************************************/
  1038. /* Old code */
  1039.  
  1040. #ifdef NOWAY     /* Attempt to allocate n objects --- not really viable
  1041. static char * allocate_bytes(LispObject *stacktop,int n);
  1042. LispObject allocate_nbytes(LispObject *stacktop, int size, int type)
  1043. {
  1044.   LispObject object;
  1045.  
  1046.   object=(LispObject) allocate_bytes(stacktop,size);
  1047.  
  1048.   lval_typeof(object)=type;
  1049.   gcof(object)=(short)wspace;
  1050.   return(object);
  1051. }
  1052.  
  1053. LispObject allocate_cbytes(LispObject *stacktop, int n, int size, int type)
  1054. {
  1055.   char *space,*ptr;
  1056.   int i;
  1057.  
  1058.   /* Hope to get lucky of alignment */
  1059.   space= allocate_bytes(stacktop,size*n);
  1060.   ptr=space;
  1061.  
  1062.   for (i=0; i<n; i++)
  1063.     {
  1064.       LispObject new;
  1065.       new=(LispObject)ptr;
  1066.       lval_typeof(new)=type;
  1067.       gcof(new)=wspace;
  1068.       
  1069.       ptr+=size;
  1070.     }
  1071.   return (LispObject) space;
  1072. }    
  1073. #endif
  1074.  
  1075.